home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops ƒ / String < prev    next >
Encoding:
Text File  |  1995-02-25  |  6.3 KB  |  267 lines  |  [TEXT/MSET]
  1. \ String class.
  2.  
  3. cr .( loading String...)
  4.  
  5. \ This class is changed radically from Neon!  We now keep two offsets into a string
  6. \ - POS and LIM.  POS marks the "current" position, and LIM the "current" end.
  7. \ Most string operations operate on the substring delimited by POS and LIM, which
  8. \ we call the active part of the string. We also keep the size of the string (the
  9. \ real size, that is) in an ivar, so that we can get it quickly without a system
  10. \ call.
  11.  
  12.    $ D    constant    RET            \ Carriage return character
  13.  
  14. : $ER
  15.     setFwind
  16.     cr ." size: " .  ."   pos: " .  ."   lim: " .
  17.     89 die   ;
  18.  
  19. ' $er  -> $err
  20.  
  21. : $=  { addr1 len1 addr2 len2 -- }
  22.     word0  addr1  addr2  len1  len2  pack  w 10
  23.     trap$ a9ed  i->l  ;
  24.  
  25. : NOPEN    ." (not open)"  ;
  26.  
  27.  
  28. :class    STRING    super{ handle }        general
  29.  
  30. record
  31. {    var    SIZE
  32.     var    POS
  33.     var    LIM
  34.     int    FLAGS
  35. }
  36.  
  37. :m COPYTO:    \ Redefinition of COPYTO: which will disallow a size change
  38.             \ on the copy.  I found it was fairly easy to do this
  39.             \ accidentally, and get into random crash territory.
  40.     copyto: super
  41.     1 put: flags   ;m
  42.  
  43.  
  44. :m MARK_ORIGINAL:
  45. \ Overrides the above check.  Marks a copy as original, so we can change its
  46. \ size.  We hope we know what we're doing.  At least this is a long name
  47. \ which could hardly get typed by accident!!
  48.  
  49.     clear: flags   ;m
  50.  
  51.  
  52. :m HANDLE:        \ this method returns the handle - replaces get: in super
  53.     inline{ obj @}
  54.     ^base @  ;m
  55.  
  56. :m POS:        \ ( -- pos )
  57.     inline{ get: pos}
  58.     get: pos  ;m
  59.  
  60. :m >POS:    \ ( newpos -- )
  61.     inline{ put: pos}
  62.     put: pos  ;m
  63.  
  64. :m LIM:        \ ( -- lim )
  65.     inline{ get: lim}
  66.     get: lim  ;m
  67.  
  68. :m >LIM:    \ ( newlim -- )
  69.     inline{ put: lim}
  70.     put: lim  ;m
  71.  
  72. :m LEN:        \ ( -- length )
  73.     get: lim  get: pos  -   ;m
  74.  
  75. :m >LEN:    \ ( newlength -- )
  76.     get: pos  +  put: lim  ;m
  77.  
  78.  
  79. :m SKIP:    \ ( n -- )  Increments POS by n.
  80.     inline{ +: pos}
  81.     +: pos  ;m
  82.  
  83. :m MORE:    \ ( n -- )  Increments LIM by n.
  84.     inline{ +: lim}
  85.     +: lim  ;m
  86.  
  87. :m START:    \ Sets POS to 0 (the start of the string).
  88.     inline{ clear: pos}
  89.     clear: pos  ;m
  90.  
  91. :m BEGIN:    \ Sets POS and LIM to 0, ready to begin some operation.
  92.     clear: pos  clear: lim   ;m
  93.  
  94. :m END:        \ Sets POS and LIM to the end of the string.
  95.     get: size  dup  put: pos  put: lim  ;m
  96.  
  97. :m NOLIM:    \ Sets LIM to the end of the string.
  98.     inline{ get: size put: lim}
  99.     get: size  put: lim  ;m
  100.  
  101. :m RESET:    \ Sets POS to 0, and LIM to the end.
  102.     inline{ clear: pos  get: size  put: lim}
  103.     clear: pos  get: size  put: lim  ;m
  104.  
  105. :m STEP:    \ Steps down the string, by setting POS to LIM and
  106.             \ then setting LIM to the end.
  107.     get: lim  put: pos  get: size  put: lim  ;m
  108.  
  109. :m <STEP:    \ Backward step.  Sets LIM to POS, then POS to 0.
  110.     get: pos  put: lim  clear: pos  ;m
  111.  
  112.  
  113. :m NEW:
  114.     0 new: super
  115.     clear: size  clear: pos  clear: lim  clear: flags  ;m
  116.     
  117. :m ?NEW:
  118.     ^base @  nilH <> ?EXIT  new: self  ;m
  119.  
  120. :m SIZE:    \ ( -- size )
  121.     inline{ get: size}
  122.     get: size   ;m
  123.  
  124. :m SETSIZE:    \ ( newsize -- )
  125.     get: flags  ?error 94        \ Can't do that on a string copy
  126.     ?new: self
  127.     dup  setsize: super  put: size  reset: self  ;m
  128.  
  129. :m CLEAR:
  130.     ?new: self  0 setsize: self  ;m
  131.  
  132. :m GET:        \ ( -- addr len ).  Gets the active part of the string.
  133.     $chk
  134.     ptr: self  get: pos  +  get: lim  get: pos  -  ;m
  135.  
  136. :m ALL:        \ ( -- addr len )    Gets all the string, ignoring POS and LIM.
  137.     ptr: self  size: self  ;m
  138.  
  139. :m 1ST:        \ ( -- c )  Returns the char at POS.
  140.     ptr: self  get: pos  +  c@  ;m
  141.  
  142. :m ^1ST:    \ ( -- addr )  Returns the addr of the char at POS.
  143.     ptr: self  get: pos  +  ;m
  144.  
  145. private
  146.  
  147. :m MUNGER:  { addr1 len1 addr2 len2 -- offs }
  148.         \ Interface to the Toolbox Munger utility
  149.     $chk
  150.     get: flags  ?error 94        \ Can't do that on a string copy
  151.        0                            \ For returned result
  152.     ^base @  get: pos
  153.     addr1 len1  addr2 len2
  154.     trap$ a9e0                    \ call Munger
  155.     size: super  put: size  ;m
  156.  
  157. public
  158.  
  159. :m UC:        \ ( -- addr len )  Converts string to upper case and gets it.
  160.     get: self  2dup  upper  ;m
  161.  
  162.  
  163. :m PUT: { addr len -- }
  164.         \ Replaces entire string with replacement string.  Does NEW:
  165.         \ if not already done.
  166.     ?new: self  clear: pos
  167.     0 -1  addr len  munger: self  put: lim  ;m
  168.  
  169. :m ->:  { str \ state -- }
  170.         \ Replaces self with the active part of string str.  We assume
  171.         \ the type, and early bind.  As the replacement may cause the
  172.         \ Mem Manager to move things, we lock str for the duration.
  173.  
  174.     str getState: string  -> state   str lock: string
  175.     str get: string   put: self
  176.     state   str setState: string   ;m
  177.  
  178.     
  179. :m INSERT:  { addr len -- }
  180.     ?new: self
  181.     addr 0 addr len  munger: self  put: pos
  182.     len +: lim  ;m
  183.  
  184.  
  185. :m $INSERT:  { str \ state -- }
  186.         \ Inserts the active text from the given relocatable
  187.         \ string, using early binding.  As the memory manager could 
  188.         \ move the source string to make room for the increase in 
  189.         \ length of SELF, we lock the source string for the
  190.         \ operation, then restore its previous state.
  191.  
  192.     str getState: string  -> state  str lock: string
  193.     str get: string  insert: self
  194.     state  str setState: string  ;m
  195.  
  196.  
  197. :m ADD: { addr len -- }
  198.     end: self
  199.     addr len  insert: self  ;m
  200.  
  201.  
  202. :m $ADD:  { str \ state -- }
  203.     str getState: string  -> state  str lock: string
  204.     str get: string  add: self
  205.     state  str setState: string  ;m
  206.  
  207.  
  208. :m +:        \ ( char -- )  Appends a char to end of string
  209.     pad c!  pad 1 add: self  ;m
  210.  
  211.  
  212. :m PRINT:
  213.     nil?: self
  214.     if   Nopen  else   get: self  type   then   ;m
  215.  
  216. \ :m   =: { theobj -- }
  217. \        \ Assigns this string to any object that accepts ( addr len )
  218. \    get: self  put: theobj  ;m
  219.  
  220. :m FILL:    \ ( c -- )
  221.     get: self  rot  fill  ;m
  222.  
  223.  
  224. \ SEARCH: and CHSEARCH: are somewhat interim.  Class String+ provides more
  225. \ efficient versions which also include case handling.  But these versions
  226. \ are short, and may be adequate for many needs.
  227.  
  228. :m SEARCH:    \ ( addr len -- b )
  229.     0 0  munger: self
  230.     dup 0< if  drop  false  else  put: lim  true  then  ;m
  231.  
  232. :m CHSEARCH:    \ ( c -- b )
  233.     pad c!  pad 1  search: self  ;m
  234.  
  235.  
  236. :m DUMP:  { \ offs svCurs -- }
  237.     nil?: self  if  Nopen  EXIT  THEN
  238.     curs -> svCurs  -curs
  239.     all: self  swap .h .h  5 spaces
  240.     ." pos: "  pos: self .h  2 spaces
  241.     ." lim: "  lim: self .h  cr
  242.     pos: self 5 - 0 max  -> offs
  243.     all: self  swap offs +  swap offs -  80 min  bounds
  244.     DO  i c@  bl 126 within?
  245.         NIF  ret = IF  $ A6  ELSE  $ D7  THEN
  246.         THEN
  247.         emit
  248.     LOOP  cr
  249.     pos: self  offs - spaces  & P  emit  cr
  250.     lim: self  offs -
  251.     dup 80 < IF  spaces  & L  emit  ELSE  drop  THEN
  252.     ^1st: self  len: self  0 max  $ 140  min  dump
  253.     svCurs -> curs  ;m
  254.  
  255. :m RD:    reset: self  dump: self  ;m        \ Handy, and short to type!
  256.  
  257. ;class
  258.  
  259. <" Files
  260.  
  261. +echo
  262.  
  263. : q db
  264.     temp{ string s }
  265.     " hello" put: s
  266.     dump: s  ;
  267.